unit FormalGrammars;

interface

uses
  SysUtils,
  JclSysUtils,
  Contnrs,
  Windows,
  JvCharStrEditor,
  JclStrings,
  JvUtils,
  Classes;

type
  TLabel = Integer;

const
  L_NONE = 0;
{$IFDEF LEXEME_DEBUG}
  L_CATCHER = 1;
{$ENDIF}

type
  IMatchResult = interface;
  ILexeme = interface(IToString)
  ['{A6BCEFF2-AC5E-49FC-8302-1EE571D37CAB}']
    function GetLabel: TLabel;
    function Match(const s: string; var ind: Integer): IMatchResult;
    property GLabel: TLabel read GetLabel;
  end;
  PLexeme = ^ILexeme;

  TLexemes = array of ILexeme;

  ILexemeWrapper = interface
  ['{BB184033-0750-492C-801D-FF6A35860F80}']
    function GetSubLexeme: ILexeme;
    property SubLexeme: ILexeme read GetSubLexeme;
  end;

  ILexemeOwner = interface
  ['{A25E7FEC-5390-4AA1-9D87-1BFF0882649E}']
    function GetSubLexemes: TLexemes;
    property SubLexemes: TLexemes read GetSubLexemes;
  end;  

  IMatchResult = interface(IInterface)
  ['{94CE1034-94D6-4B1A-8170-23BB3780315A}']
    function GetSuccess: Boolean;
    function GetLabel: TLabel;

    property Success: Boolean read GetSuccess;
    property GLabel: TLabel read GetLabel;
  end;

  IMatchError = interface(IMatchResult)
  ['{88DCD383-5ED2-41F2-A582-7FB109BFAFDE}']
    function GetPosition: Integer;
    function GetErrorMessage: string;

    property Position: Integer read GetPosition;
    property ErrorMessage: string read GetErrorMessage;
  end;

  IMatchSuccess = interface(IMatchResult)
  ['{CC99A256-AF25-4743-A46A-CD5EDE6D4FEF}']
    function GetMatch(const i: Integer): IMatchSuccess;
    function GetValueFrom: Integer;
    function GetValueTo: Integer;
    function GetMatchCount: Integer;

    property ValueFrom: Integer read GetValueFrom;
    property ValueTo: Integer read GetValueTo;
    property MatchCount: Integer read GetMatchCount;
    property Matches[const i: Integer]: IMatchSuccess read GetMatch; default;
  end;

  IGrammar = interface(ILexemeWrapper)
  ['{DD4E9011-A3C1-47E5-B01E-46D5E29821AB}']
    function Apply(const aTarget: string; out error: IMatchError; out res: IMatchSuccess): Boolean;
    function Find(const aTarget: string; const aStartIndex: Integer = 1): IMatchSuccess;
  end;

{$IFDEF LEXEME_DEBUG}
  ICatcherLexeme = interface(ILexeme)
  ['{EF89AC39-DD22-4FD1-830F-5C1895BFC756}']
    function GetID: Integer;
    procedure SetID(const Value: Integer);
    property ID: Integer read GetID write SetID;
  end;
{$ENDIF}

  TFilterFunction = function(const s: string; var ind: Integer): Boolean;
  TConditionFunction = function(const s: string; const l: ILexeme; const r: IMatchSuccess): Boolean;
{$IFDEF LEXEME_DEBUG}
  TCheckConformProc = procedure(const aLexeme: ILexeme; const aTarget: string);
  TCheckAllProc = procedure(const l: ILexeme; const args: array of string);
  TLexemeMatchEvent = function(const aLexeme: ILexeme): Boolean of object;
  
  ECatcher = class(Exception)
  strict private
    fCatcher: ICatcherLexeme;
  public
    constructor Create(const aCatcher: ICatcherLexeme);
    property Catcher: ICatcherLexeme read fCatcher;
  end;
{$ENDIF}

function Grammar(const aRootElement: ILexeme): IGrammar;
function GText(const aText: string; aLabel: TLabel = L_NONE): ILexeme;
function GMaybe(const aElem: ILexeme): ILexeme; overload;
function GMaybe(const aElems: array of ILexeme): ILexeme; overload;
function GSequence(const aSeq: array of ILexeme; const aLabel: TLabel = L_NONE): ILexeme;
function GSymbols(const aSet: TSysCharSet; const aLabel: TLabel = L_NONE): ILexeme;
function GRepeats(const aElem: ILexeme; const aLabel: TLabel = L_NONE; const aMinTimes: Integer = 0; const aMaxTimes: Integer = MaxInt): ILexeme; overload;
function GRepeat(const aElems: array of ILexeme; const aMinTimes: Integer = 0; const aLabel: TLabel = L_NONE): ILexeme; overload;
function GRepeat(const aLexeme, aSeparator: ILexeme; const aLabel: TLabel = L_NONE): ILexeme; overload;
function GRepeat(const aStatement: array of ILexeme; const aSeparator: array of ILexeme; const aLabel: TLabel = L_NONE): ILexeme; overload;
function GFilter(const aFilter: TFilterFunction; const aLabel: TLabel = L_NONE): ILexeme; overload;
function GFilter(const aTarget: ILexeme; const aCondition: TConditionFunction; const aLabel: TLabel = L_NONE): ILexeme; overload;
function GSelect(const alternatives: array of ILexeme; const aLabel: TLabel = L_NONE): ILexeme;
function GFar(const aLexeme: PLexeme): ILexeme;
{$IFDEF LEXEME_DEBUG}
function GDebug(const aLexeme: ILexeme): ILexeme;
function GCatch(const aLexeme: ILexeme; aCatcher: TLexemeMatchEvent): ICatcherLexeme;
function GCatchTree(const aLexeme: ILexeme; const aCatcher: TLexemeMatchEvent): ICatcherLexeme;
{$ENDIF}
procedure RegisterLabel(const l: TLabel; const Title: string);
function GetLabelTitle(const l: TLabel): string;
function IsLabelRegistered(const l: TLabel): Boolean;

procedure UnitTest;

implementation

var
  gLabels: array of string;

type
  TCustomLexeme = class abstract(TInterfacedObject)
  strict private
    fLabel: TLabel;
  protected
    procedure ReSetLabel(const aMR: IMatchResult); inline;
    function GetLexemeType: string; virtual; abstract;
    function GetLabel: TLabel;
  public
    constructor Create(const aLabel: TLabel = L_NONE);
    function ToString: string;
  end;

  TCustomLexemeWrapper = class abstract(TCustomLexeme)
  protected
    fElement: ILexeme;
    function GetSubLexeme: ILexeme;    
  public
    constructor Create(const aElement: ILexeme; const aLabel: TLabel = L_NONE);
  end;

{$IFDEF LEXEME_DEBUG}
  TDebugLexeme = class sealed(TCustomLexemeWrapper, ILexeme)
  protected
    function GetLexemeType: string; override;
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TCatchLexeme = class sealed(TCustomLexemeWrapper, ICatcherLexeme, ILexeme)
  strict private
    fCatcher: TLexemeMatchEvent;
    fID: Cardinal;
  protected
    function GetLexemeType: string; override;
    function GetID: Integer;
    procedure SetID(const Value: Integer);    
  public
    constructor Create(const aLexeme: ILexeme; const aCatcher: TLexemeMatchEvent);
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;
{$ENDIF}

  TCustomLexemeOwner = class abstract(TCustomLexeme)
  protected
    fElements: TLexemes;
    function GetSubLexemes: TLexemes;    
  public
    constructor Create(const aElements: TLexemes; const aLabel: TLabel);
  end;

  TTextGrammarElement = class sealed(TCustomLexeme, ILexeme)
  strict private
    fText: string;
  protected
    function GetLexemeType: string; override;
  public
    constructor Create(const aText: string; const aLabel: TLabel = L_NONE);
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TOptionalGrammarElement = class sealed(TCustomLexemeWrapper, ILexeme, ILexemeWrapper)
  protected
    function GetLexemeType: string; override;
  public
    constructor Create(const aElement: ILexeme);
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TSequenceGrammarElement = class sealed(TCustomLexemeOwner, ILexeme, ILexemeOwner)
  protected
    function GetLexemeType: string; override;
  public
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TTextExGrammarElement = class sealed(TCustomLexeme, ILexeme)
  strict private
    fSymbols: TSysCharSet;
  protected
    function GetLexemeType: string; override;
  public
    constructor Create(const aSymbols: TSysCharSet; const aLabel: TLabel);
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TRepeatedGrammarElement = class sealed(TCustomLexemeWrapper, ILexeme, ILexemeWrapper)
  strict private
    fMaxTimes,
    fMinTimes: Integer;
  protected
    function GetLexemeType: string; override;
  public
    constructor Create(const aElement: ILexeme; const aLabel: TLabel = L_NONE; const minTimes: Integer = 0; const maxTimes: Integer = MaxInt);
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TFilterGrammarElement = class sealed(TCustomLexeme, ILexeme)
  strict private
    fFilter: TFilterFunction;
  protected
    function GetLexemeType: string; override;
    constructor Create(const aFilter: TFilterFunction; const aLabel: TLabel);
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TConditionGrammarElement = class sealed(TCustomLexemeWrapper, ILexeme)
  strict private
    fCondition: TConditionFunction;
  protected
    function GetLexemeType: string; override;
  public
    constructor Create(const aCond: TConditionFunction; const aLexeme: ILexeme; const aLabel: TLabel);
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TSelectLexeme = class sealed(TCustomLexemeOwner, ILexeme, ILexemeOwner)
  protected
    function GetLexemeType: string; override;
  public
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TFarLexeme = class sealed(TCustomLexeme, ILexeme)
  strict private
    fLexeme: PLexeme;
  protected
    function GetLexemeType: string; override;
  public
    constructor Create(const aLexeme: PLexeme);
    function Match(const s: string; var ind: Integer): IMatchResult;
  end;

  TGrammar = class sealed(TInterfacedObject, IGrammar)
  strict private
    fRoot: ILexeme;
  protected
    function GetSubLexeme: ILexeme;
  public
    constructor Create(const aRootElement: ILexeme);
    destructor Destroy; override;
    function Apply(const aTarget: string; out error: IMatchError; out res: IMatchSuccess): Boolean;
    function Find(const aTarget: string; const aStartIndex: Integer = 1): IMatchSuccess;
  end;

  TCustomMatchResult = class abstract(TInterfacedObject)
  strict private
    fLabel: TLabel;
  protected
    function GetLabel: TLabel;
    procedure SetLabel(const aLabel: TLabel); inline;  
  public
    constructor Create(const aLabel: TLabel);
  end;

  TMatchError = class sealed(TCustomMatchResult, IMatchError, IMatchResult)
  strict private
    fPosition: Integer;
    fErrorMessage: string;
  protected
    function GetSuccess: Boolean;
    function GetPosition: Integer;
    function GetErrorMessage: string;    
  public
    constructor Create(const aPosition: Integer; const aError: string; const aLabel: TLabel);
  end;

  TMatchSuccess = class sealed(TCustomMatchResult, IMatchSuccess, IMatchResult)
  strict private
    fValueFrom: Integer;
    fValueTo: Integer;
    fSubMatches: TInterfaceList;
  private
    constructor Create(const aMatches: TInterfaceList; const aLabel: TLabel); overload;
  protected
    function GetMatch(const i: Integer): IMatchSuccess;
    function GetSuccess: Boolean;
    function GetValueFrom: Integer;
    function GetValueTo: Integer;
    function GetMatchCount: Integer;    
  public
    constructor Create(const aValueFrom, aValueTo: Integer; const aLabel: TLabel); overload;
    destructor Destroy; override;
  end;

function Grammar(const aRootElement: ILexeme): IGrammar; 
begin
  Assert(Assigned(aRootElement));
  Result := TGrammar.Create(aRootElement);
end;

function GText(const aText: string; aLabel: TLabel): ILexeme;
begin
  Assert(aText <> '');
  Result := TTextGrammarElement.Create(aText, aLabel);
end;

function GMaybe(const aElem: ILexeme): ILexeme; 
begin
  Assert(Assigned(aElem));
// TODO: Implement Assert(not (aElem is TOptionalGrammarElement));
  Result := TOptionalGrammarElement.Create(aElem);
end;

function GMaybe(const aElems: array of ILexeme): ILexeme;
begin
  Result := GMaybe(GSequence(aElems));
end;

function GSequence(const aSeq: array of ILexeme; const aLabel: TLabel): ILexeme;
var
  a: TLexemes;
  i: Integer;
begin
  Assert(High(aSeq) > 0, 'Sequense should have at least two elements');
  SetLength(a, High(aSeq) + 1);
  for i := Low(aSeq) to High(aSeq) do
  begin
    Assert(Assigned(aSeq[i]));
    // TODO: Optimize by inlining Sequence Lexeme into parent sequence
    a[i] := aSeq[i];
  end;
  Result := TSequenceGrammarElement.Create(a, aLabel);
end;

function GSymbols(const aSet: TSysCharSet; const aLabel: TLabel = L_NONE): ILexeme;
begin
  Assert(aSet <> []);
  Result := TTextExGrammarElement.Create(aSet, aLabel);
end;

function GRepeats(const aElem: ILexeme; const aLabel: TLabel = L_NONE; const aMinTimes: Integer = 0; const aMaxTimes: Integer = MaxInt): ILexeme;
begin
  Assert(Assigned(aElem));
  Result := TRepeatedGrammarElement.Create(aElem, aLabel, aMinTimes, aMaxTimes);
end;

function GRepeat(const aElems: array of ILexeme; const aMinTimes: Integer = 0; const aLabel: TLabel = L_NONE): ILexeme; overload;
begin
  Result := GRepeats(GSequence(aElems), L_NONE, aMinTimes);
end;

function GFilter(const aFilter: TFilterFunction; const aLabel: TLabel): ILexeme;
begin
  Assert(Assigned(aFilter));
  Result := TFilterGrammarElement.Create(aFilter, aLabel);
end;

function GFilter(const aTarget: ILexeme; const aCondition: TConditionFunction; const aLabel: TLabel = L_NONE): ILexeme;
begin
  Assert(Assigned(aTarget) and Assigned(aCondition));
  Result := TConditionGrammarElement.Create(aCondition, aTarget, aLabel);
end;

function GSelect(const alternatives: array of ILexeme; const aLabel: TLabel = L_NONE): ILexeme;
var
  al: TLexemes;
  i: Integer;
begin
  Assert(High(alternatives) > 0);
  SetLength(al, High(alternatives) + 1);
  for i := Low(alternatives) to High(alternatives) do
  begin
    Assert(Assigned(alternatives[i]));
    al[i] := alternatives[i];
  end;
  Result := TSelectLexeme.Create(al, aLabel);
end;

function GFar(const aLexeme: PLexeme): ILexeme;
begin
  Result := TFarLexeme.Create(aLexeme);
end;

function GRepeat(const aLexeme, aSeparator: ILexeme; const aLabel: TLabel): ILexeme;
begin
  Result := GSequence([
    aLexeme,
    GRepeat([
      aSeparator,
      aLexeme
    ])
  ], aLabel);
end;

function GRepeat(const aStatement: array of ILexeme; const aSeparator: array of ILexeme; const aLabel: TLabel): ILexeme;
begin
  Result := GRepeat(
    GSequence(aStatement),
    GSequence(aSeparator),
    aLabel
  );
end;

{$IFDEF LEXEME_DEBUG}
function GDebug(const aLexeme: ILexeme): ILexeme;
begin
  Assert(Assigned(aLexeme));
  Result := TDebugLexeme.Create(aLexeme);
end;

function GCatch(const aLexeme: ILexeme; aCatcher: TLexemeMatchEvent): ICatcherLexeme; 
begin
  Assert(Assigned(aLexeme) and Assigned(aCatcher));
  Result := TCatchLexeme.Create(aLexeme, aCatcher);
end;

// TODO: Implement correct lexeme ILexeme recursive tree cloning 
procedure DoCatchChildrensRecursive(const aLexeme: ILexeme; const aCatcher: TLexemeMatchEvent);
var
  w: ILexemeWrapper;
  o: ILexemeOwner;
  i: ILexeme;
begin
  if not Supports(aLexeme, ICatcherLexeme) then
  begin
    if Supports(aLexeme, ILexemeWrapper, w) then
    begin
      DoCatchChildrensRecursive(w.SubLexeme, aCatcher);
      //w.fSubLexeme := GCatch(w.SubLexeme, aCatcher);
    end
    else if Supports(aLexeme, ILexemeOwner, o) then
    begin
      for i in o.SubLexemes do
      begin
        DoCatchChildrensRecursive(i, aCatcher);
      end;
    end;
  end;
end;

function GCatchTree(const aLexeme: ILexeme; const aCatcher: TLexemeMatchEvent): ICatcherLexeme;
begin
  DoCatchChildrensRecursive(aLexeme, aCatcher);
  Result := GCatch(aLexeme, aCatcher);  
end;

{$ENDIF}

procedure RegisterLabel(const l: TLabel; const Title: string);
begin
  Assert(Title <> '');
  if Integer(l) > High(gLabels) then
    SetLength(gLabels, Integer(l) + 10);
  if gLabels[Integer(l)] = '' then
    gLabels[Integer(l)] := Title
  else
    raise Exception.CreateFmt('Label "%d" is already registered', [Integer(l)])
end;

function GetLabelTitle(const l: TLabel): string;
begin
  if IsLabelRegistered(l) then
    Result := gLabels[Integer(l)]
  else
    raise Exception.CreateFmt('Label "%d" is not registered', [Integer(l)]);
end;

function IsLabelRegistered(const l: TLabel): Boolean;
begin
  Result := (Integer(l) <= High(gLabels)) and (gLabels[Integer(l)] <> '');
end;

{$IFDEF LEXEME_DEBUG}
procedure UnitTest;
var
  g: IGrammar;
  e: IMatchError;
  r: IMatchSuccess;
begin
  g := Grammar(GText('test'));
  Assert(g.Apply('test', e, r));
  Assert((r.GetValueFrom = 1) and (r.GetValueTo = 4));

  Assert(not g.Apply(' test', e, r));

  g := Grammar(
    GSequence([
      GText('t1'),
      GText('t2')
    ])
  );
  Assert(g.Apply('t1t2', e, r));
  Assert(r.GetMatchCount = 2);

  Assert(not g.Apply('t1 t2', e, r));

  g := Grammar(
    GSequence([
      GMaybe(GText('t1')),
      GMaybe(GText('t2'))
    ])
  );
  Assert(g.Apply('t1t2', e, r));
  Assert(r.GetMatchCount = 2);

  Assert(g.Apply('t1', e, r));
  Assert(r.GetMatchCount = 1);
  Assert(g.Apply('t2', e, r));
  Assert(r.GetMatchCount = 1);
  Assert(not g.Apply('', e, r));
  Assert(not g.Apply('t1 t2', e, r));

  g := Grammar(
    GSequence([
      GSymbols(['A'..'Z']),
      GSymbols(['a'..'z'])
    ])
  );
  Assert(g.Apply('ABCabc', e, r));
  Assert((r[0].GetValueFrom = 1) and (r[1].GetValueFrom = 4));

  g := Grammar(
    GRepeats(
      GSequence([
        GText('a'),
        GText('b')
      ])
    )
  );
  Assert(g.Apply('abababababab', e, r));
  Assert(r.GetMatchCount = 6);
end;
{$ENDIF}

{ TCustomLexeme }

constructor TCustomLexeme.Create(const aLabel: TLabel);
begin
  Assert(IsLabelRegistered(aLabel), 'Label is not registered');
  fLabel := aLabel;
end;

function TCustomLexeme.GetLabel: TLabel;
begin
  Result := fLabel;
end;

procedure TCustomLexeme.ReSetLabel(const aMR: IMatchResult);
begin
  if Integer(TCustomMatchResult(aMR).GetLabel) = L_NONE then
    TCustomMatchResult(aMR).SetLabel(GetLabel);
end;

function TCustomLexeme.ToString: string;
begin
  if fLabel <> L_NONE then
    Result := GetLabelTitle(fLabel) + ' ' + GetLexemeType
  else
    Result := GetLexemeType;
end;

{ TTextGrammarElement }

constructor TTextGrammarElement.Create(const aText: string; const aLabel: TLabel);
begin
  inherited Create(aLabel);
  fText := UpperCase(aText);
end;

function TTextGrammarElement.GetLexemeType: string;
begin
  Result := '<Text>: ' + fText;
end;

function TTextGrammarElement.Match(const s: string; var ind: Integer): IMatchResult;
var
  i: Integer;
begin
  if Length(s) - ind + 1 >= Length(fText) then
  begin
    for i := 1 to Length(fText) do
    begin
      if UpCase(s[ind + i - 1]) <> fText[i] then
      begin
        Result := TMatchError.Create(ind + i - 1, '', GetLabel);
        Exit;
      end;
    end;
    Result := TMatchSuccess.Create(ind, ind + Length(fText) -1, GetLabel);
    Inc(ind, Length(fText));
  end
  else
    Result := TMatchError.Create(ind, '', GetLabel);
end;

{ TMatchResult }

constructor TMatchSuccess.Create(const aValueFrom, aValueTo: Integer; const aLabel: TLabel);
begin
  inherited Create(aLabel);
  Self.fValueFrom := aValueFrom;
  Self.fValueTo := aValueTo;
end;

constructor TMatchSuccess.Create(const aMatches: TInterfaceList; const aLabel: TLabel);
begin
  inherited Create(aLabel);
  if aMatches.Count = 0 then
    raise Exception.Create('Matches list cannot be empty');
  fValueFrom := IMatchSuccess(aMatches[0]).GetValueFrom;
  fValueTo := IMatchSuccess(aMatches[aMatches.Count - 1]).GetValueTo;
  fSubMatches := aMatches;
end;

destructor TMatchSuccess.Destroy;
begin
  fSubMatches.Free;
  inherited;
end;

function TMatchSuccess.GetMatch(const i: Integer): IMatchSuccess;
begin
  if not Supports(fSubMatches[i], IMatchSuccess, Result) then
    raise Exception.Create('Invalid operation');

end;

function TMatchSuccess.GetMatchCount: Integer;
begin
  if Assigned(fSubMatches) then
    Result := fSubMatches.Count
  else
    Result := 0;
end;

function TMatchSuccess.GetSuccess: Boolean;
begin
  Result := True;
end;

function TMatchSuccess.GetValueFrom: Integer;
begin
  Result := fValueFrom;

end;

function TMatchSuccess.GetValueTo: Integer;
begin
  Result := fValueTo;
end;

{ IGrammar }

function TGrammar.Apply(const aTarget: string; out error: IMatchError; out res: IMatchSuccess): Boolean;
var
  ind: Integer;
  lr: IMatchResult;
begin
  error := nil;
  res := nil;
  ind := 1;
  lr := fRoot.Match(aTarget, ind);
  if Assigned(lr) and (lr.GetSuccess) then
  begin
    if ind = Length(aTarget) + 1 then
    begin
      Result := True;
      res := lr as IMatchSuccess;
    end
    else
    begin
      Result := False;
      error := TMatchError.Create(ind, 'Uknown identifier', L_NONE);
    end;
  end
  else
  begin
    Result := False;
    error := lr as IMatchError;
  end;
end;

constructor TGrammar.Create(const aRootElement: ILexeme);
begin
  fRoot := aRootElement;
end;

destructor TGrammar.Destroy;
begin
  inherited;
end;

function TGrammar.Find(const aTarget: string; const aStartIndex: Integer = 1): IMatchSuccess;
var
  ind, i: Integer;
  ar: IMatchResult;
begin
  Result := nil;
  for i := aStartIndex to Length(aTarget) do
  begin
    ind := i;
    ar := fRoot.Match(aTarget, ind);
    if Assigned(ar) and ar.GetSuccess then
      Result := IMatchSuccess(ar);
  end;
end;

function TGrammar.GetSubLexeme: ILexeme;
begin
  Result := fRoot;
end;

{ TOptionalGrammarElement }

constructor TOptionalGrammarElement.Create(const aElement: ILexeme);
begin
  inherited Create(aElement);
end;

function TOptionalGrammarElement.GetLexemeType: string;
begin
  Result := '<Optional>';
end;

function TOptionalGrammarElement.Match(const s: string; var ind: Integer): IMatchResult;
begin
  Result := fElement.Match(s, ind);
  if Assigned(Result) then
  begin
    if not Result.GetSuccess then
    begin
      Result := nil;
    end
    else
      ReSetLabel(Result);
  end;
end;


{ TSequenceGrammarElement }

function TSequenceGrammarElement.GetLexemeType: string;
begin
  Result := '<Sequence>';
end;

function TSequenceGrammarElement.Match(const s: string; var ind: Integer): IMatchResult;
var
  e: ILexeme;
  list: TInterfaceList;
  lInd: Integer;
begin
  list := nil;
  lInd := ind;
  for e in fElements do
  begin
    Result := e.Match(s, lInd);
    if Assigned(Result) then
    begin
      if Result.GetSuccess then
      begin
        if not Assigned(list) then
          list := TInterfaceList.Create;
        list.Add(Result);
      end
      else
      begin
        list.Free;
        ReSetLabel(Result);
        Exit;
      end;
    end;
  end;
  if Assigned(list) then
  begin
    ind := lInd;
    Result := TMatchSuccess.Create(list, GetLabel);
  end
  else
    Result := TMatchError.Create(lInd, '', GetLabel);
end;

{ TTextExGrammarElement }

constructor TTextExGrammarElement.Create(const aSymbols: TSysCharSet; const aLabel: TLabel);
begin
  inherited Create(aLabel);
  fSymbols := aSymbols;   
end;

function TTextExGrammarElement.GetLexemeType: string;
begin
  Result := '<Symbols>' + SysCharSetToString(fSymbols, True);
end;

function TTextExGrammarElement.Match(const s: string; var ind: Integer): IMatchResult;
var
  f: Integer;
  l: Integer;
begin
  l := Length(s);
  if (ind <= l) and (s[ind] in fSymbols) then
  begin
    f := ind;
    Inc(ind);
    while (ind <= l) and (s[ind] in fSymbols) do
      Inc(ind);
    Result := TMatchSuccess.Create(f, ind - 1, GetLabel);
  end
  else
    Result := TMatchError.Create(ind, '', GetLabel);
end;

{ TCustomParentGrammarElement }

constructor TCustomLexemeWrapper.Create(const aElement: ILexeme; const aLabel: TLabel);
begin
  inherited Create(aLabel);
  fElement := aElement;
end;

{ TRepeatedGrammarElement }

constructor TRepeatedGrammarElement.Create(const aElement: ILexeme; const aLabel: TLabel = L_NONE; const minTimes: Integer = 0; const maxTimes: Integer = MaxInt);
begin
  inherited Create(aElement, aLabel);
  fMinTimes := minTimes;
  fMaxTimes := maxTimes;
end;

function TRepeatedGrammarElement.GetLexemeType: string;
begin
  Result := '<Repeat>';
end;

function TRepeatedGrammarElement.Match(const s: string; var ind: Integer): IMatchResult;
var
  times: Integer;
  list: TInterfaceList;
  lInd: Integer;
begin
  list := nil;
  times := 0;
  lInd := ind;
  while True do
  begin
    Result := fElement.Match(s, lInd);
    if Assigned(Result) and Result.GetSuccess then
    begin
      Inc(times);
      if times >= fMaxTimes then
      begin
        list.Free;
        Result := TMatchError.Create(lInd, 'Too many occurences', GetLabel);
        Exit;
      end;
      
      if not Assigned(list) then
        list := TInterfaceList.Create;
      list.Add(Result);
    end
    else
      Break;
  end;

  if times >= fMinTimes then
  begin
    if Assigned(list) then
    begin
      Result := TMatchSuccess.Create(list, GetLabel);
      ind := lInd;
    end
    else
    begin
      if fMinTimes <= 0 then
        Result := nil
      else
        Result := TMatchError.Create(ind, 'Too little occurences', GetLabel);
    end;
  end
  else
  begin
    list.Free;
    Result := TMatchError.Create(ind, 'Too many occurences', GetLabel);
  end;
end;


{ TGrammarMatchError }

constructor TMatchError.Create(const aPosition: Integer; const aError: string; const aLabel: TLabel);
begin
  fPosition := aPosition;
  fErrorMessage := aError;
end;

function TMatchError.GetErrorMessage: string;
begin
  Result := fErrorMessage;
end;

function TMatchError.GetPosition: Integer;
begin
  Result := fPosition;
end;

function TMatchError.GetSuccess: Boolean;
begin
  Result := False;
end;

{ TFilterGrammarElement }

constructor TFilterGrammarElement.Create(const aFilter: TFilterFunction; const aLabel: TLabel);
begin
  fFilter := aFilter;
end;

function TFilterGrammarElement.GetLexemeType: string;
begin
  Result := '<Filter>';
end;

function TFilterGrammarElement.Match(const s: string; var ind: Integer): IMatchResult;
var
  lind: Integer;
begin
  lind := ind;
  if fFilter(s, lind) then
  begin
    Result := TMatchSuccess.Create(ind, lind - 1, GetLabel);
    ind := lind;
  end
  else
    Result := TMatchError.Create(ind, '', GetLabel);
end;

function TCustomLexemeWrapper.GetSubLexeme: ILexeme;
begin
  Result := fElement;
end;

{ TSelectLexeme }

function TSelectLexeme.GetLexemeType: string;
begin
  Result := '<Select>';
end;

function TSelectLexeme.Match(const s: string; var ind: Integer): IMatchResult;
var
  l: ILexeme;
  lInd: Integer;
begin
  for l in fElements do
  begin
    lInd := ind;
    Result := l.Match(s, lInd);
    if Assigned(Result) and Result.Success then
    begin
      ReSetLabel(Result);
      ind := lInd;
      Exit;
    end;
  end;
  Result := TMatchError.Create(ind, '', GetLabel);
end;

{ TCustomLexemeOwner }

constructor TCustomLexemeOwner.Create(const aElements: TLexemes; const aLabel: TLabel);
begin
  inherited Create(aLabel);
  fElements := aElements;
end;

function TCustomLexemeOwner.GetSubLexemes: TLexemes;
begin
  Result := fElements;
end;

{ TRecurseLexeme }

constructor TFarLexeme.Create(const aLexeme: PLexeme);
begin
  fLexeme := aLexeme;
end;

{$IFDEF LEXEME_DEBUG}
threadvar
  gFarCallCount: Cardinal;
  gCatcherLastID: Integer;
{$ENDIF}

function TFarLexeme.GetLexemeType: string;
begin
  Assert(Assigned(fLexeme));
  Result := fLexeme.ToString;
end;

function TFarLexeme.Match(const s: string; var ind: Integer): IMatchResult;
begin
{$IFDEF LEXEME_DEBUG}
  Inc(gFarCallCount);
  Assert(gFarCallCount < 20);  // Catching stack overflow
{$ENDIF}
  Assert(Assigned(fLexeme^));
// TODO: Optimize using replacement this instance of TFarLexeme by already assigned fLexeme on Parent
  Result := fLexeme^.Match(s, ind);
  ReSetLabel(Result);
{$IFDEF LEXEME_DEBUG}
  Dec(gFarCallCount);
{$ENDIF}
end;

{ TCustomMatchResult }

constructor TCustomMatchResult.Create(const aLabel: TLabel);
begin
  fLabel := aLabel;
end;

function TCustomMatchResult.GetLabel: TLabel;
begin
  Result := fLabel;
end;

procedure TCustomMatchResult.SetLabel(const aLabel: TLabel);
begin
  Assert(fLabel = L_NONE, 'Cannot change label');
  fLabel := aLabel;
end;

{$IFDEF LEXEME_DEBUG}
{ TDebugLexeme }                               

function TDebugLexeme.GetLexemeType: string;
begin
  Result := fElement.ToString;
end;

function TDebugLexeme.Match(const s: string; var ind: Integer): IMatchResult;
begin
  DebugBreak;
  Result := fElement.Match(s, ind);
end;

{ TCatchLexeme }

constructor TCatchLexeme.Create(const aLexeme: ILexeme; const aCatcher: TLexemeMatchEvent);
begin
  inherited Create(aLexeme, L_CATCHER);
  fCatcher := aCatcher;
  fID := InterlockedIncrement(gCatcherLastID);
end;

function TCatchLexeme.GetID: Integer;
begin
  Result := fID;
end;

function TCatchLexeme.GetLexemeType: string;
begin
  Result := 'Catcher';
end;

function TCatchLexeme.Match(const s: string; var ind: Integer): IMatchResult;
begin
  if fCatcher(fElement) then
    Result := fElement.Match(s, ind)
  else
    raise ECatcher.Create(Self);
end;

procedure TCatchLexeme.SetID(const Value: Integer);
begin
  fID := Value;
end;

{ ECatcher }

constructor ECatcher.Create(const aCatcher: ICatcherLexeme);
begin
  fCatcher := aCatcher;
end;

{$ENDIF}

{ TConditionGrammarElement }

constructor TConditionGrammarElement.Create(const aCond: TConditionFunction; const aLexeme: ILexeme; const aLabel: TLabel);
begin
  inherited Create(aLexeme, aLabel);
  fCondition := aCond;
end;

function TConditionGrammarElement.GetLexemeType: string;
begin
  Result := 'Conditional ' + fElement.ToString;
end;

function TConditionGrammarElement.Match(const s: string; var ind: Integer): IMatchResult;
begin
  Result := fElement.Match(s, ind);
  if Result.Success then
  begin
    if not fCondition(s, fElement, Result as IMatchSuccess) then
      Result := TMatchError.Create(ind, '', GetLabel)
    else
      ReSetLabel(Result);
  end
  else
    ReSetLabel(Result);
end;

initialization
  RegisterLabel(L_NONE, 'No matched');
{$IFDEF LEXEME_DEBUG}
  RegisterLabel(L_CATCHER, 'Catcher');
{$ENDIF}

end.
